#' Do you expect an error, warning, message, or other condition?
#'
#' @description
#' `expect_error()`, `expect_warning()`, `expect_message()`, and
#' `expect_condition()` check that code throws an error, warning, message,
#' or condition with a message that matches `regexp`, or a class that inherits
#' from `class`. See below for more details.
#'
#' In the 3rd edition, these functions match (at most) a single condition. All
#' additional and non-matching (if `regexp` or `class` are used) conditions
#' will bubble up outside the expectation. If these additional conditions
#' are important you'll need to catch them with additional
#' `expect_message()`/`expect_warning()` calls; if they're unimportant you
#' can ignore with [suppressMessages()]/[suppressWarnings()].
#'
#' It can be tricky to test for a combination of different conditions,
#' such as a message followed by an error. [expect_snapshot()] is
#' often an easier alternative for these more complex cases.
#'
#' @section Testing `message` vs `class`:
#' When checking that code generates an error, it's important to check that the
#' error is the one you expect. There are two ways to do this. The first
#' way is the simplest: you just provide a `regexp` that match some fragment
#' of the error message. This is easy, but fragile, because the test will
#' fail if the error message changes (even if its the same error).
#'
#' A more robust way is to test for the class of the error, if it has one.
#' You can learn more about custom conditions at
#' <https://adv-r.hadley.nz/conditions.html#custom-conditions>, but in
#' short, errors are S3 classes and you can generate a custom class and check
#' for it using `class` instead of `regexp`.
#'
#' If you are using `expect_error()` to check that an error message is
#' formatted in such a way that it makes sense to a human, we recommend
#' using [expect_snapshot()] instead.
#'
#' @export
#' @family expectations
#' @inheritParams expect_that
#' @param regexp Regular expression to test against.
#'   * A character vector giving a regular expression that must match the
#'     error message.
#'   * If `NULL`, the default, asserts that there should be an error,
#'     but doesn't test for a specific value.
#'   * If `NA`, asserts that there should be no errors, but we now recommend
#'     using [expect_no_error()] and friends instead.
#'
#'   Note that you should only use `message` with errors/warnings/messages
#'   that you generate. Avoid tests that rely on the specific text generated by
#'   another package since this can easily change. If you do need to test text
#'   generated by another package, either protect the test with `skip_on_cran()`
#'   or use `expect_snapshot()`.
#' @inheritDotParams expect_match -object -regexp -info -label -all
#' @param class Instead of supplying a regular expression, you can also supply
#'   a class name. This is useful for "classed" conditions.
#' @param inherit Whether to match `regexp` and `class` across the
#'   ancestry of chained errors.
#' @param all *DEPRECATED* If you need to test multiple warnings/messages
#'   you now need to use multiple calls to `expect_message()`/
#'   `expect_warning()`
#' @seealso [expect_no_error()], `expect_no_warning()`,
#'   `expect_no_message()`, and `expect_no_condition()` to assert
#'   that code runs without errors/warnings/messages/conditions.
#' @return If `regexp = NA`, the value of the first argument; otherwise
#'   the captured condition.
#' @examples
#' # Errors ------------------------------------------------------------------
#' f <- function() stop("My error!")
#' expect_error(f())
#' expect_error(f(), "My error!")
#'
#' # You can use the arguments of grepl to control the matching
#' expect_error(f(), "my error!", ignore.case = TRUE)
#'
#' # Note that `expect_error()` returns the error object so you can test
#' # its components if needed
#' err <- expect_error(rlang::abort("a", n = 10))
#' expect_equal(err$n, 10)
#'
#' # Warnings ------------------------------------------------------------------
#' f <- function(x) {
#'   if (x < 0) {
#'     warning("*x* is already negative")
#'     return(x)
#'   }
#'   -x
#' }
#' expect_warning(f(-1))
#' expect_warning(f(-1), "already negative")
#' expect_warning(f(1), NA)
#'
#' # To test message and output, store results to a variable
#' expect_warning(out <- f(-1), "already negative")
#' expect_equal(out, -1)
#'
#' # Messages ------------------------------------------------------------------
#' f <- function(x) {
#'   if (x < 0) {
#'     message("*x* is already negative")
#'     return(x)
#'   }
#'
#'   -x
#' }
#' expect_message(f(-1))
#' expect_message(f(-1), "already negative")
#' expect_message(f(1), NA)
expect_error <- function(
  object,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  info = NULL,
  label = NULL
) {
  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
  check_string(class, allow_null = TRUE)
  check_bool(inherit)

  if (edition_get() >= 3) {
    expect_condition_matching_(
      "error",
      {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label
    )
  } else {
    act <- quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
    msg <- compare_condition_2e(
      act$cap,
      act$lab,
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit
    )

    # Access error fields with `[[` rather than `$` because the
    # `$.Throwable` from the rJava package throws with unknown fields
    if (!is.null(msg)) {
      fail(msg, info = info, trace = act$cap[["trace"]])
    } else {
      pass()
    }
    invisible(act$val %||% act$cap)
  }
}


#' @export
#' @rdname expect_error
expect_warning <- function(
  object,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  all = FALSE,
  info = NULL,
  label = NULL
) {
  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
  check_string(class, allow_null = TRUE)
  check_bool(inherit)
  check_bool(all)

  if (edition_get() >= 3) {
    if (!missing(all)) {
      cli::cli_warn("The {.arg all} argument is deprecated.")
    }

    expect_condition_matching_(
      "warning",
      {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label
    )
  } else {
    act <- quasi_capture(
      enquo(object),
      label,
      capture_warnings,
      ignore_deprecation = identical(regexp, NA)
    )
    msg <- compare_messages(
      act$cap,
      act$lab,
      regexp = regexp,
      all = all,
      ...,
      cond_type = "warnings"
    )
    if (!is.null(msg)) {
      fail(msg, info = info)
    } else {
      pass()
    }
    invisible(act$val)
  }
}

#' @export
#' @rdname expect_error
expect_message <- function(
  object,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  all = FALSE,
  info = NULL,
  label = NULL
) {
  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
  check_string(class, allow_null = TRUE)
  check_bool(inherit)
  check_bool(all)

  if (edition_get() >= 3) {
    expect_condition_matching_(
      "message",
      {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label
    )
  } else {
    act <- quasi_capture(enquo(object), label, capture_messages)
    msg <- compare_messages(act$cap, act$lab, regexp = regexp, all = all, ...)
    if (!is.null(msg)) {
      fail(msg, info = info)
    } else {
      pass()
    }
    invisible(act$val)
  }
}

#' @export
#' @rdname expect_error
expect_condition <- function(
  object,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  info = NULL,
  label = NULL
) {
  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
  check_string(class, allow_null = TRUE)
  check_bool(inherit)

  if (edition_get() >= 3) {
    expect_condition_matching_(
      "condition",
      {{ object }},
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      info = info,
      label = label
    )
  } else {
    act <- quasi_capture(
      enquo(object),
      label,
      capture_condition,
      entrace = TRUE
    )
    msg <- compare_condition_2e(
      act$cap,
      act$lab,
      regexp = regexp,
      class = class,
      ...,
      inherit = inherit,
      cond_type = "condition"
    )
    if (!is.null(msg)) {
      fail(msg, info = info, trace = act$cap[["trace"]])
    } else {
      pass()
    }
    invisible(act$val %||% act$cap)
  }
}

expect_condition_matching_ <- function(
  base_class,
  object,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  info = NULL,
  label = NULL,
  trace_env = caller_env(),
  error_call = caller_env()
) {
  check_condition_dots(regexp, ..., error_call = error_call)
  matcher <- cnd_matcher(
    base_class,
    class,
    regexp,
    ...,
    inherit = inherit,
    ignore_deprecation = base_class == "warning" && identical(regexp, NA),
    error_call = error_call
  )

  act <- quasi_capture(
    enquo(object),
    label,
    capture_matching_condition,
    matches = matcher
  )

  expected <- !identical(regexp, NA)
  msg <- compare_condition_3e(base_class, class, act$cap, act$lab, expected)

  # Access error fields with `[[` rather than `$` because the
  # `$.Throwable` from the rJava package throws with unknown fields
  if (!is.null(msg)) {
    fail(
      msg,
      info = info,
      trace = act$cap[["trace"]],
      trace_env = trace_env
    )
  } else {
    pass()
  }
  # If a condition was expected, return it. Otherwise return the value
  # of the expression.
  invisible(if (expected) act$cap else act$val)
}

# -------------------------------------------------------------------------

cnd_matcher <- function(
  base_class,
  class = NULL,
  regexp = NULL,
  ...,
  inherit = TRUE,
  ignore_deprecation = FALSE,
  error_call = caller_env()
) {
  check_string(class, allow_null = TRUE, call = error_call)
  check_string(regexp, allow_null = TRUE, allow_na = TRUE, call = error_call)

  function(cnd) {
    if (!inherit) {
      cnd$parent <- NULL
    }

    if (ignore_deprecation && is_deprecation(cnd)) {
      return(FALSE)
    }

    matcher <- function(x) {
      if (!inherits(x, base_class)) {
        return(FALSE)
      }
      if (!is.null(class) && !inherits(x, class)) {
        return(FALSE)
      }
      if (!is.null(regexp) && !identical(regexp, NA)) {
        withCallingHandlers(
          grepl(regexp, conditionMessage(x), ...),
          error = function(e) {
            cli::cli_abort(
              "Failed to compare {base_class} to {.arg regexp}.",
              parent = e,
              call = error_call
            )
          }
        )
      } else {
        TRUE
      }
    }
    cnd_some(cnd, matcher)
  }
}

has_classes <- function(x, classes) {
  all(classes %in% class(x))
}

is_deprecation <- function(x) {
  inherits(x, "lifecycle_warning_deprecated")
}

cnd_some <- function(.cnd, .p, ...) {
  .p <- as_function(.p)

  while (is_condition(.cnd)) {
    if (.p(.cnd, ...)) {
      return(TRUE)
    }

    .cnd <- .cnd$parent
  }

  FALSE
}

capture_matching_condition <- function(expr, matches) {
  matched <- NULL
  tl <- current_env()

  withCallingHandlers(expr, condition = function(cnd) {
    if (!is.null(matched) || !matches(cnd)) {
      return()
    }

    if (can_entrace(cnd)) {
      cnd <- cnd_entrace(cnd)
    }
    matched <<- cnd

    if (inherits(cnd, "message") || inherits(cnd, "warning")) {
      cnd_muffle(cnd)
    } else if (inherits(cnd, "error") || inherits(cnd, "skip")) {
      return_from(tl, cnd)
    }
  })

  matched
}

# Helpers -----------------------------------------------------------------

compare_condition_3e <- function(cond_type, cond_class, cond, lab, expected) {
  if (expected) {
    if (is.null(cond)) {
      if (is.null(cond_class)) {
        sprintf("Expected %s to throw a %s.", lab, cond_type)
      } else {
        sprintf(
          "Expected %s to throw a %s with class <%s>.",
          lab,
          cond_type,
          cond_class
        )
      }
    } else {
      NULL
    }
  } else {
    if (!is.null(cond)) {
      c(
        sprintf("Expected %s not to throw any %ss.", lab, cond_type),
        actual_condition(cond)
      )
    } else {
      NULL
    }
  }
}

compare_condition_2e <- function(
  cond,
  lab,
  regexp = NULL,
  class = NULL,
  ...,
  inherit = TRUE,
  cond_type = "error"
) {
  # Expecting no condition
  if (identical(regexp, NA)) {
    if (!is.null(cond)) {
      return(sprintf(
        "%s threw an %s.\nMessage: %s\nClass:   %s",
        lab,
        cond_type,
        cnd_message(cond),
        paste(class(cond), collapse = "/")
      ))
    } else {
      return()
    }
  }

  # Otherwise we're definitely expecting a condition
  if (is.null(cond)) {
    return(sprintf("Expected %s to throw a %s.", lab, cond_type))
  }

  matches <- cnd_matches_2e(cond, class, regexp, inherit, ...)
  ok_class <- matches[["class"]]
  ok_msg <- matches[["msg"]]

  # All good
  if (ok_msg && ok_class) {
    return()
  }

  problems <- c(if (!ok_class) "class", if (!ok_msg) "message")
  message <- cnd_message(cond)

  details <- c(
    if (!ok_class) {
      sprintf(
        "Expected class: %s\nActual class:   %s\nMessage:        %s",
        paste0(class, collapse = "/"),
        paste0(class(cond), collapse = "/"),
        message
      )
    },
    if (!ok_msg) {
      sprintf(
        "Expected match: %s\nActual message: %s",
        encodeString(regexp, quote = '"'),
        encodeString(message, quote = '"')
      )
    }
  )

  sprintf(
    "%s threw an %s with unexpected %s.\n%s",
    lab,
    cond_type,
    paste(problems, collapse = " and "),
    paste(details, collapse = "\n")
  )
}

cnd_matches_2e <- function(cnd, class, regexp, inherit, ...) {
  if (!inherit) {
    cnd$parent <- NULL
  }

  ok_class <- is.null(class) || cnd_inherits(cnd, class)
  ok_msg <- is.null(regexp) ||
    cnd_some(cnd, function(x) {
      any(grepl(regexp, cnd_message(x), ...))
    })

  c(class = ok_class, msg = ok_msg)
}


compare_messages <- function(
  messages,
  lab,
  regexp = NA,
  ...,
  all = FALSE,
  cond_type = "messages"
) {
  bullets <- paste0("* ", messages, collapse = "\n")
  # Expecting no messages
  if (identical(regexp, NA)) {
    if (length(messages) > 0) {
      return(sprintf(
        "Expected %s not to generate %s.\nActually generated:\n%s",
        lab,
        cond_type,
        bullets
      ))
    } else {
      return()
    }
  }

  # Otherwise we're definitely expecting messages
  if (length(messages) == 0) {
    return(sprintf("Expected %s to produce %s.", lab, cond_type))
  }

  if (is.null(regexp)) {
    return()
  }

  matched <- grepl(regexp, messages, ...)

  # all/any ok
  if ((all && all(matched)) || (!all && any(matched))) {
    return()
  }

  sprintf(
    "%s produced unexpected %s.\n%s\n%s",
    lab,
    cond_type,
    paste0("Expected match: ", encodeString(regexp)),
    paste0("Actual values:\n", bullets)
  )
}

# Disable rlang backtrace reminders so they don't interfere with
# expected error messages
cnd_message <- function(x) {
  withr::local_options(rlang_backtrace_on_error = "none")
  conditionMessage(x)
}

check_condition_dots <- function(
  regexp = NULL,
  ...,
  error_call = caller_env()
) {
  if (!is.null(regexp) || missing(...)) {
    return()
  }

  dot_names <- ...names()
  if (is.null(dot_names)) {
    dot_names <- rep("", ...length())
  }
  unnamed <- dot_names == ""
  dot_names[unnamed] <- paste0("..", seq_along(dot_names)[unnamed])

  cli::cli_abort(
    c(
      "Can't supply {.arg ...} unless {.arg regexp} is set.",
      "*" = "Unused arguments: {.arg {dot_names}}.",
      i = "Did you mean to use {.arg regexp} so {.arg ...} is passed to {.fn grepl}?"
    ),
    call = error_call
  )
}

actual_condition <- function(cond) {
  paste0(
    "Actually got a <",
    class(cond)[[1]],
    "> with message:\n",
    indent_lines(cnd_message(cond))
  )
}
